home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / t / op / closure.t < prev    next >
Text File  |  1998-07-11  |  12KB  |  483 lines
  1. #!./perl
  2. #                              -*- Mode: Perl -*-
  3. # closure.t:
  4. #   Original written by Ulrich Pfeifer on 2 Jan 1997.
  5. #   Greatly extended by Tom Phoenix <rootbeer@teleport.com> on 28 Jan 1997.
  6. #
  7.  
  8. BEGIN {
  9.     chdir 't' if -d 't';
  10.     @INC = '../lib';
  11. }
  12.  
  13. use Config;
  14.  
  15. print "1..169\n";
  16.  
  17. my $test = 1;
  18. sub test (&) {
  19.   print ((&{$_[0]})?"ok $test\n":"not ok $test\n");
  20.   $test++;
  21. }
  22.  
  23. my $i = 1;
  24. sub foo { $i = shift if @_; $i }
  25.  
  26. # no closure
  27. test { foo == 1 };
  28. foo(2);
  29. test { foo == 2 };
  30.  
  31. # closure: lexical outside sub
  32. my $foo = sub {$i = shift if @_; $i };
  33. my $bar = sub {$i = shift if @_; $i };
  34. test {&$foo() == 2 };
  35. &$foo(3);
  36. test {&$foo() == 3 };
  37. # did the lexical change?
  38. test { foo == 3 and $i == 3};
  39. # did the second closure notice?
  40. test {&$bar() == 3 };
  41.  
  42. # closure: lexical inside sub
  43. sub bar {
  44.   my $i = shift;
  45.   sub { $i = shift if @_; $i }
  46. }
  47.  
  48. $foo = bar(4);
  49. $bar = bar(5);
  50. test {&$foo() == 4 };
  51. &$foo(6);
  52. test {&$foo() == 6 };
  53. test {&$bar() == 5 };
  54.  
  55. # nested closures
  56. sub bizz {
  57.   my $i = 7;
  58.   if (@_) {
  59.     my $i = shift;
  60.     sub {$i = shift if @_; $i };
  61.   } else {
  62.     my $i = $i;
  63.     sub {$i = shift if @_; $i };
  64.   }
  65. }
  66. $foo = bizz();
  67. $bar = bizz();
  68. test {&$foo() == 7 };
  69. &$foo(8);
  70. test {&$foo() == 8 };
  71. test {&$bar() == 7 };
  72.  
  73. $foo = bizz(9);
  74. $bar = bizz(10);
  75. test {&$foo(11)-1 == &$bar()};
  76.  
  77. my @foo;
  78. for (qw(0 1 2 3 4)) {
  79.   my $i = $_;
  80.   $foo[$_] = sub {$i = shift if @_; $i };
  81. }
  82.  
  83. test {
  84.   &{$foo[0]}() == 0 and
  85.   &{$foo[1]}() == 1 and
  86.   &{$foo[2]}() == 2 and
  87.   &{$foo[3]}() == 3 and
  88.   &{$foo[4]}() == 4
  89.   };
  90.  
  91. for (0 .. 4) {
  92.   &{$foo[$_]}(4-$_);
  93. }
  94.  
  95. test {
  96.   &{$foo[0]}() == 4 and
  97.   &{$foo[1]}() == 3 and
  98.   &{$foo[2]}() == 2 and
  99.   &{$foo[3]}() == 1 and
  100.   &{$foo[4]}() == 0
  101.   };
  102.  
  103. sub barf {
  104.   my @foo;
  105.   for (qw(0 1 2 3 4)) {
  106.     my $i = $_;
  107.     $foo[$_] = sub {$i = shift if @_; $i };
  108.   }
  109.   @foo;
  110. }
  111.  
  112. @foo = barf();
  113. test {
  114.   &{$foo[0]}() == 0 and
  115.   &{$foo[1]}() == 1 and
  116.   &{$foo[2]}() == 2 and
  117.   &{$foo[3]}() == 3 and
  118.   &{$foo[4]}() == 4
  119.   };
  120.  
  121. for (0 .. 4) {
  122.   &{$foo[$_]}(4-$_);
  123. }
  124.  
  125. test {
  126.   &{$foo[0]}() == 4 and
  127.   &{$foo[1]}() == 3 and
  128.   &{$foo[2]}() == 2 and
  129.   &{$foo[3]}() == 1 and
  130.   &{$foo[4]}() == 0
  131.   };
  132.  
  133. # test if closures get created in optimized for loops
  134.  
  135. my %foo;
  136. for my $n ('A'..'E') {
  137.     $foo{$n} = sub { $n eq $_[0] };
  138. }
  139.  
  140. test {
  141.   &{$foo{A}}('A') and
  142.   &{$foo{B}}('B') and
  143.   &{$foo{C}}('C') and
  144.   &{$foo{D}}('D') and
  145.   &{$foo{E}}('E')
  146. };
  147.  
  148. for my $n (0..4) {
  149.     $foo[$n] = sub { $n == $_[0] };
  150. }
  151.  
  152. test {
  153.   &{$foo[0]}(0) and
  154.   &{$foo[1]}(1) and
  155.   &{$foo[2]}(2) and
  156.   &{$foo[3]}(3) and
  157.   &{$foo[4]}(4)
  158. };
  159.  
  160. # Additional tests by Tom Phoenix <rootbeer@teleport.com>.
  161.  
  162. {
  163.     use strict;
  164.  
  165.     use vars qw!$test!;
  166.     my($debugging, %expected, $inner_type, $where_declared, $within);
  167.     my($nc_attempt, $call_outer, $call_inner, $undef_outer);
  168.     my($code, $inner_sub_test, $expected, $line, $errors, $output);
  169.     my(@inners, $sub_test, $pid);
  170.     $debugging = 1 if defined($ARGV[0]) and $ARGV[0] eq '-debug';
  171.  
  172.     # The expected values for these tests
  173.     %expected = (
  174.     'global_scalar'    => 1001,
  175.     'global_array'    => 2101,
  176.     'global_hash'    => 3004,
  177.     'fs_scalar'    => 4001,
  178.     'fs_array'    => 5101,
  179.     'fs_hash'    => 6004,
  180.     'sub_scalar'    => 7001,
  181.     'sub_array'    => 8101,
  182.     'sub_hash'    => 9004,
  183.     'foreach'    => 10011,
  184.     );
  185.  
  186.     # Our innermost sub is either named or anonymous
  187.     for $inner_type (qw!named anon!) {
  188.       # And it may be declared at filescope, within a named
  189.       # sub, or within an anon sub
  190.       for $where_declared (qw!filescope in_named in_anon!) {
  191.     # And that, in turn, may be within a foreach loop,
  192.     # a naked block, or another named sub
  193.     for $within (qw!foreach naked other_sub!) {
  194.  
  195.       # Here are a number of variables which show what's
  196.       # going on, in a way.
  197.       $nc_attempt = 0+        # Named closure attempted
  198.           ( ($inner_type eq 'named') ||
  199.           ($within eq 'other_sub') ) ;
  200.       $call_inner = 0+        # Need to call &inner
  201.           ( ($inner_type eq 'anon') &&
  202.           ($within eq 'other_sub') ) ;
  203.       $call_outer = 0+        # Need to call &outer or &$outer
  204.           ( ($inner_type eq 'anon') &&
  205.           ($within ne 'other_sub') ) ;
  206.       $undef_outer = 0+        # $outer is created but unused
  207.           ( ($where_declared eq 'in_anon') &&
  208.           (not $call_outer) ) ;
  209.  
  210.       $code = "# This is a test script built by t/op/closure.t\n\n";
  211.  
  212.       $code .= <<"DEBUG_INFO" if $debugging;
  213. # inner_type: $inner_type 
  214. # where_declared: $where_declared 
  215. # within: $within
  216. # nc_attempt: $nc_attempt
  217. # call_inner: $call_inner
  218. # call_outer: $call_outer
  219. # undef_outer: $undef_outer
  220. DEBUG_INFO
  221.  
  222.       $code .= <<"END_MARK_ONE";
  223.  
  224. BEGIN { \$SIG{__WARN__} = sub { 
  225.     my \$msg = \$_[0];
  226. END_MARK_ONE
  227.  
  228.       $code .=  <<"END_MARK_TWO" if $nc_attempt;
  229.     return if index(\$msg, 'will not stay shared') != -1;
  230.     return if index(\$msg, 'may be unavailable') != -1;
  231. END_MARK_TWO
  232.  
  233.       $code .= <<"END_MARK_THREE";        # Backwhack a lot!
  234.     print "not ok: got unexpected warning \$msg\\n";
  235. } }
  236.  
  237. {
  238.     my \$test = $test;
  239.     sub test (&) {
  240.       my \$result = &{\$_[0]};
  241.       print "not " unless \$result;
  242.       print "ok \$test\\n";
  243.       \$test++;
  244.     }
  245. }
  246.  
  247. # some of the variables which the closure will access
  248. \$global_scalar = 1000;
  249. \@global_array = (2000, 2100, 2200, 2300);
  250. %global_hash = 3000..3009;
  251.  
  252. my \$fs_scalar = 4000;
  253. my \@fs_array = (5000, 5100, 5200, 5300);
  254. my %fs_hash = 6000..6009;
  255.  
  256. END_MARK_THREE
  257.  
  258.       if ($where_declared eq 'filescope') {
  259.         # Nothing here
  260.       } elsif ($where_declared eq 'in_named') {
  261.         $code .= <<'END';
  262. sub outer {
  263.   my $sub_scalar = 7000;
  264.   my @sub_array = (8000, 8100, 8200, 8300);
  265.   my %sub_hash = 9000..9009;
  266. END
  267.     # }
  268.       } elsif ($where_declared eq 'in_anon') {
  269.         $code .= <<'END';
  270. $outer = sub {
  271.   my $sub_scalar = 7000;
  272.   my @sub_array = (8000, 8100, 8200, 8300);
  273.   my %sub_hash = 9000..9009;
  274. END
  275.     # }
  276.       } else {
  277.         die "What was $where_declared?"
  278.       }
  279.  
  280.       if ($within eq 'foreach') {
  281.         $code .= "
  282.       my \$foreach = 12000;
  283.       my \@list = (10000, 10010);
  284.       foreach \$foreach (\@list) {
  285.     " # }
  286.       } elsif ($within eq 'naked') {
  287.         $code .= "  { # naked block\n"    # }
  288.       } elsif ($within eq 'other_sub') {
  289.         $code .= "  sub inner_sub {\n"    # }
  290.       } else {
  291.         die "What was $within?"
  292.       }
  293.  
  294.       $sub_test = $test;
  295.       @inners = ( qw!global_scalar global_array global_hash! ,
  296.         qw!fs_scalar fs_array fs_hash! );
  297.       push @inners, 'foreach' if $within eq 'foreach';
  298.       if ($where_declared ne 'filescope') {
  299.         push @inners, qw!sub_scalar sub_array sub_hash!;
  300.       }
  301.       for $inner_sub_test (@inners) {
  302.  
  303.         if ($inner_type eq 'named') {
  304.           $code .= "    sub named_$sub_test "
  305.         } elsif ($inner_type eq 'anon') {
  306.           $code .= "    \$anon_$sub_test = sub "
  307.         } else {
  308.           die "What was $inner_type?"
  309.         }
  310.  
  311.         # Now to write the body of the test sub
  312.         if ($inner_sub_test eq 'global_scalar') {
  313.           $code .= '{ ++$global_scalar }'
  314.         } elsif ($inner_sub_test eq 'fs_scalar') {
  315.           $code .= '{ ++$fs_scalar }'
  316.         } elsif ($inner_sub_test eq 'sub_scalar') {
  317.           $code .= '{ ++$sub_scalar }'
  318.         } elsif ($inner_sub_test eq 'global_array') {
  319.           $code .= '{ ++$global_array[1] }'
  320.         } elsif ($inner_sub_test eq 'fs_array') {
  321.           $code .= '{ ++$fs_array[1] }'
  322.         } elsif ($inner_sub_test eq 'sub_array') {
  323.           $code .= '{ ++$sub_array[1] }'
  324.         } elsif ($inner_sub_test eq 'global_hash') {
  325.           $code .= '{ ++$global_hash{3002} }'
  326.         } elsif ($inner_sub_test eq 'fs_hash') {
  327.           $code .= '{ ++$fs_hash{6002} }'
  328.         } elsif ($inner_sub_test eq 'sub_hash') {
  329.           $code .= '{ ++$sub_hash{9002} }'
  330.         } elsif ($inner_sub_test eq 'foreach') {
  331.           $code .= '{ ++$foreach }'
  332.         } else {
  333.           die "What was $inner_sub_test?"
  334.         }
  335.       
  336.         # Close up
  337.         if ($inner_type eq 'anon') {
  338.           $code .= ';'
  339.         }
  340.         $code .= "\n";
  341.         $sub_test++;    # sub name sequence number
  342.  
  343.       } # End of foreach $inner_sub_test
  344.  
  345.       # Close up $within block        # {
  346.       $code .= "  }\n\n";
  347.  
  348.       # Close up $where_declared block
  349.       if ($where_declared eq 'in_named') {    # {
  350.         $code .= "}\n\n";
  351.       } elsif ($where_declared eq 'in_anon') {    # {
  352.         $code .= "};\n\n";
  353.       }
  354.  
  355.       # We may need to do something with the sub we just made...
  356.       $code .= "undef \$outer;\n" if $undef_outer;
  357.       $code .= "&inner_sub;\n" if $call_inner;
  358.       if ($call_outer) {
  359.         if ($where_declared eq 'in_named') {
  360.           $code .= "&outer;\n\n";
  361.         } elsif ($where_declared eq 'in_anon') {
  362.           $code .= "&\$outer;\n\n"
  363.         }
  364.       }
  365.  
  366.       # Now, we can actually prep to run the tests.
  367.       for $inner_sub_test (@inners) {
  368.         $expected = $expected{$inner_sub_test} or
  369.           die "expected $inner_sub_test missing";
  370.  
  371.         # Named closures won't access the expected vars
  372.         if ( $nc_attempt and 
  373.         substr($inner_sub_test, 0, 4) eq "sub_" ) {
  374.           $expected = 1;
  375.         }
  376.  
  377.         # If you make a sub within a foreach loop,
  378.         # what happens if it tries to access the 
  379.         # foreach index variable? If it's a named
  380.         # sub, it gets the var from "outside" the loop,
  381.         # but if it's anon, it gets the value to which
  382.         # the index variable is aliased.
  383.         #
  384.         # Of course, if the value was set only
  385.         # within another sub which was never called,
  386.         # the value has not been set yet.
  387.         #
  388.         if ($inner_sub_test eq 'foreach') {
  389.           if ($inner_type eq 'named') {
  390.         if ($call_outer || ($where_declared eq 'filescope')) {
  391.           $expected = 12001
  392.         } else {
  393.           $expected = 1
  394.         }
  395.           }
  396.         }
  397.  
  398.         # Here's the test:
  399.         if ($inner_type eq 'anon') {
  400.           $code .= "test { &\$anon_$test == $expected };\n"
  401.         } else {
  402.           $code .= "test { &named_$test == $expected };\n"
  403.         }
  404.         $test++;
  405.       }
  406.  
  407.       if ($Config{d_fork} and $^O ne 'VMS' and $^O ne 'MSWin32') {
  408.         # Fork off a new perl to run the tests.
  409.         # (This is so we can catch spurious warnings.)
  410.         $| = 1; print ""; $| = 0; # flush output before forking
  411.         pipe READ, WRITE or die "Can't make pipe: $!";
  412.         pipe READ2, WRITE2 or die "Can't make second pipe: $!";
  413.         die "Can't fork: $!" unless defined($pid = open PERL, "|-");
  414.         unless ($pid) {
  415.           # Child process here. We're going to send errors back
  416.           # through the extra pipe.
  417.           close READ;
  418.           close READ2;
  419.           open STDOUT, ">&WRITE"  or die "Can't redirect STDOUT: $!";
  420.           open STDERR, ">&WRITE2" or die "Can't redirect STDERR: $!";
  421.           exec './perl', '-w', '-'
  422.         or die "Can't exec ./perl: $!";
  423.         } else {
  424.           # Parent process here.
  425.           close WRITE;
  426.           close WRITE2;
  427.           print PERL $code;
  428.           close PERL;
  429.           { local $/;
  430.             $output = join '', <READ>;
  431.             $errors = join '', <READ2>; }
  432.           close READ;
  433.           close READ2;
  434.         }
  435.       } else {
  436.         # No fork().  Do it the hard way.
  437.         my $cmdfile = "tcmd$$";  $cmdfile++ while -e $cmdfile;
  438.         my $errfile = "terr$$";  $errfile++ while -e $errfile;
  439.         my @tmpfiles = ($cmdfile, $errfile);
  440.         open CMD, ">$cmdfile"; print CMD $code; close CMD;
  441.         my $cmd = (($^O eq 'VMS') ? "MCR $^X"
  442.                : ($^O eq 'MSWin32') ? '.\perl'
  443.                : './perl');
  444.         $cmd .= " -w $cmdfile 2>$errfile";
  445.         if ($^O eq 'VMS' or $^O eq 'MSWin32') {
  446.           # Use pipe instead of system so we don't inherit STD* from
  447.           # this process, and then foul our pipe back to parent by
  448.           # redirecting output in the child.
  449.           open PERL,"$cmd |" or die "Can't open pipe: $!\n";
  450.           { local $/; $output = join '', <PERL> }
  451.           close PERL;
  452.         } else {
  453.           my $outfile = "tout$$";  $outfile++ while -e $outfile;
  454.           push @tmpfiles, $outfile;
  455.           system "$cmd >$outfile";
  456.           { local $/; open IN, $outfile; $output = <IN>; close IN }
  457.         }
  458.         if ($?) {
  459.           printf "not ok: exited with error code %04X\n", $?;
  460.           $debugging or do { 1 while unlink @tmpfiles };
  461.           exit;
  462.         }
  463.         { local $/; open IN, $errfile; $errors = <IN>; close IN }
  464.         1 while unlink @tmpfiles;
  465.       }
  466.       print $output;
  467.       print STDERR $errors;
  468.       if ($debugging && ($errors || $? || ($output =~ /not ok/))) {
  469.         my $lnum = 0;
  470.         for $line (split '\n', $code) {
  471.           printf "%3d:  %s\n", ++$lnum, $line;
  472.         }
  473.       }
  474.       printf "not ok: exited with error code %04X\n", $? if $?;
  475.       print "-" x 30, "\n" if $debugging;
  476.  
  477.     }    # End of foreach $within
  478.       }    # End of foreach $where_declared
  479.     }    # End of foreach $inner_type
  480.  
  481. }
  482.  
  483.